home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / ilisp / allegro.lisp.z / allegro.lisp
Encoding:
Text File  |  1998-05-21  |  2.6 KB  |  88 lines
  1. ;;; -*- Mode: Lisp -*-
  2.  
  3. ;;; allegro.lisp --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.8
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
  11. ;;;               1996 Marco Antoniotti and Rick Campbell
  12. ;;;
  13. ;;; Other authors' names for which this Copyright notice also holds
  14. ;;; may appear later in this file.
  15. ;;;
  16. ;;; Send mail to 'ilisp-request@naggum.no' to be included in the
  17. ;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP
  18. ;;; mailing list were bugs and improvements are discussed.
  19. ;;;
  20. ;;; ILISP is freely redistributable under the terms found in the file
  21. ;;; COPYING.
  22.  
  23. ;;;
  24. ;;; Allegro initializations
  25. ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  26. ;;;
  27. (in-package "ILISP")
  28.  
  29. ;;;
  30. (defun ilisp-callers (symbol package)
  31.   "Print a list of all of the functions that call FUNCTION and return
  32. T if successful." 
  33.   (ilisp-errors
  34.    (let ((function (ilisp-find-symbol symbol package))
  35.      (callers nil)
  36.      (*print-level* nil)
  37.      (*print-length* nil)
  38.      (*package* (find-package 'lisp)))
  39.      (when (and function (fboundp function))
  40.        (labels ((in-expression (function expression)
  41.           (cond ((null expression) nil)
  42.             ((listp expression)
  43.              (let ((header (first expression)))
  44.                (if (or (eq header function)
  45.                    (and (eq header 'function)
  46.                     (eq (second expression) function)))
  47.                    t
  48.                    (dolist (subexp expression)
  49.                  (when (in-expression function subexp)
  50.                    (return t)))))))))
  51.      (excl::who-references
  52.       function
  53.       #'(lambda (function)
  54.           (push (excl::fn_symdef function) callers)))
  55.      (do-all-symbols (symbol)
  56.        (when (and (fboundp symbol)
  57.               (not (compiled-function-p (symbol-function symbol)))
  58.               (in-expression function (symbol-function symbol)))
  59.          (push symbol callers)))
  60.      (dolist (caller callers)
  61.        (print caller))
  62.      t)))))
  63.  
  64. ;;;
  65. (defun ilisp-source-files (symbol package type)
  66.   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  67. return T if successful."
  68.   (ilisp-errors
  69.    (let* ((symbol (ilisp-find-symbol symbol package))
  70.       (type (if (equal type "any") t (ilisp-find-symbol type "keyword")))
  71.       (paths (when symbol (excl:source-file symbol type))))
  72.      (if paths
  73.      (progn
  74.        (if (eq type t)
  75.            (dolist (path (remove-duplicates paths
  76.                         :key #'cdr :test #'equal))
  77.          (print (namestring (cdr path))))
  78.            (print (namestring paths)))
  79.        t)
  80.      nil))))
  81.  
  82. ;;;
  83. (dolist (symbol '(ilisp-callers ilisp-source-files))
  84.   (export symbol))
  85. (unless (compiled-function-p #'ilisp-callers)
  86.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  87.  
  88.